home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / SETIMP.f < prev    next >
Text File  |  1992-07-31  |  2KB  |  70 lines
  1.       SUBROUTINE SETIMP 
  2. *-----------------------------------------------------------------------
  3. *   
  4. *   Sets the default type list for an IMPLICIT statement, updates the   
  5. *   already existing routine names  (except for strongly typed).
  6. *   
  7. *-----------------------------------------------------------------------
  8.       include 'PARAM.h' 
  9.       include 'ALCAZA.h' 
  10.       include 'CONDEC.h' 
  11.       include 'FLWORK.h' 
  12.       include 'CURSTA.h' 
  13.       include 'TYPDEF.h' 
  14.       CHARACTER STYP(6)*16,STEMP*1,SPREV*1,STEMP2*2 
  15.       DIMENSION LTYP(6) 
  16.       DATA STYP/'#INTEGER','#REAL','#LOGICAL','#COMPLEX',   
  17.      +'#DOUBLEPRECISION','#CHARACTER'/  
  18.       DATA LTYP/8,5,8,8,16,10/  
  19.       include 'CONDAT.h' 
  20.       IPT=0 
  21.    10 CONTINUE  
  22.       IND=NCHST 
  23.       DO 20 I=1,6   
  24.          CALL MATCH(STYP(I),1,LTYP(I),SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV
  25.      +   ,NSPEC,IWS,IWS)
  26.          IF (IPOS.GT.0.AND.IPOS.LE.IND)  THEN   
  27.             IND=IPOS
  28.             IT=I
  29.          ENDIF  
  30.    20 CONTINUE  
  31.       IF (IND+3.GT.NCHST) GOTO 999  
  32.       IPT=IND   
  33. *--- skip possible '*(...)' following the key   
  34.       CALL GETNBL(SSTA(IPT+1:NCHST),STEMP2,NN)  
  35.       IF (NN.LT.2) GOTO 999 
  36.       IF(STEMP2.EQ.'*(')  THEN  
  37.          IPT=IPT+INDEX(SSTA(IPT+1:NCHST),'(')   
  38.          CALL SKIPLV(SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV)
  39.          IF (IPOS.EQ.0) GOTO 999
  40.          IPT=IPOS   
  41.       ENDIF 
  42. *--- get start and end of bracket following type
  43.       IND=INDEX(SSTA(IPT+1:NCHST),'(')  
  44.       IF (IND.EQ.0) GOTO 999
  45.       IPT=IPT+IND   
  46.       CALL SKIPLV(SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV)   
  47.       IF (IPOS.EQ.0) GOTO 999   
  48. *--- loop over bracket, set type, reset types routine name table
  49.       SPREV=' ' 
  50.       KP=27 
  51.       DO 40 I=IPT+1,IPOS-1  
  52.          STEMP=SSTA(I:I)
  53.          IF (STEMP.EQ.' ') GOTO 40  
  54.          K=ICVAL(STEMP) 
  55.          IF (K.GT.0.AND.K.LE.26)  THEN  
  56.             IF (SPREV.EQ.'-')  THEN 
  57.                DO 30 J=KP,K 
  58.                   KVTYPE(J)=IT  
  59.    30          CONTINUE 
  60.             ELSE
  61.                KVTYPE(K)=IT 
  62.             ENDIF   
  63.             KP=K
  64.          ENDIF  
  65.          SPREV=STEMP
  66.    40 CONTINUE  
  67.       IPT=IPOS  
  68.       GOTO 10   
  69.   999 END   
  70.